home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 5 / Apprentice-Release5.iso / Environments / Yerk 3.6.8 / tool+ / popUp6 < prev    next >
Encoding:
Text File  |  1994-11-29  |  5.9 KB  |  190 lines  |  [TEXT/YERK]
  1. \ pmenu knows how to popup when asked, and it keeps track of
  2. \    which item was selected, and it allows for an x,y offset
  3. \    for display purposes
  4.  
  5. :CLASS pmenu <super hmenu
  6.  
  7.     int        type        \ 0: 'offset' rel to mouse;1: use 'offset' as absolute
  8.     point    offset        \ if type=0, then MOUSE will be offset from upper left
  9.                         \  corner of menu.
  10.     int        lastPick    \ refers to item number (starting from 1)
  11.  
  12. \ determines if popup appears offset to mouse, or at absolute position
  13.   :M type: ( n --) put: type ;M
  14.  
  15.   :M popup: ( -- )
  16.     0 get: mHndl
  17.     get: type
  18.     IF   int: offset l->g intSwap
  19.     ELSE where: fevent unpack gety: offset - swap getx: offset - pack
  20.     THEN
  21.     int: lastpick   call popupmenuselect
  22.     unpack  -> menuId  -> mitem
  23.     mitem 0 >
  24.     IF get: resid menuId =                            \ is mouse in popUp?
  25.        IF   mitem put: lastPick mitem exec: self    \ yes
  26.        ELSE mitem menuId exec: menubar                \ must be hierarchical submenu
  27.        THEN 
  28.     ELSE 0 -> menuid
  29.     THEN ;M
  30.  
  31. \ this is coded to allow for getting the text item of a hierarchical menu
  32. \ attached to the popup
  33.   :M getText: ( item# -- addr len)
  34.         0 menuId makeInt call getMHandle            \ get menuhandle
  35.         swap makeint buf255 +base call GetItem    \ get text of selected item
  36.         buf255 count ;M
  37.  
  38.   :M offset: ( x y -- ) put: offset ;M
  39. \  :M position: ( x y -- ) put: self ;M
  40.  
  41.   :M putitem: ( lastPick -- ) put: lastPick ;M
  42.   :M getitem: ( -- lastPick ) get: lastPick ;M
  43.   :M getHItemName: ( -- addr len) get: lastPick getText: self ;M
  44.  
  45. \ inits to relative offset to mouse
  46.   :M classinit: 25 9 offset: self classinit: super ;M
  47.  
  48. ;CLASS
  49.  
  50.  
  51. \ stringvar - class of strings which are kept in memory
  52. \             as barrays and have a max length - from mh
  53. \ 5.24.89    rfl    twidth and type replaces stringwidth and drawstring
  54. \                 inset rect before print and changed 2 to 1 in justification
  55. \ 12.4.89    rfl a few modifications cosmetic
  56. \ 5.24.90    rfl    redid justinbox stuff to shorten code
  57. \ 7.12.92    rfl    deleted stringvar class
  58. \ 5.20.93    rfl    removed cursor stuff
  59. \ 8.4.93    rfl    mitem now points to text (from 1 not zero)...compatible with new pMenu fix. PROPOGATES
  60. \ 10.20.93    rfl    fixed exec: to not exec if no item was selected
  61. \  3.3.94    rfl    set: window for print: also
  62. \  4.26.94    rfl    uncommented in firstName:
  63.  
  64. \ Bitmap class for drawing bitmaps to screen
  65. :CLASS bMap  <Super warray
  66.  
  67.     Var        BaseAddr
  68.     Int        RowBytes
  69.     Rect    BndsRect
  70.     rect    DestRect
  71.  
  72.     \ (  n  l t r b -- )
  73.     :M  INIT:   Put:  bndsRect  Put: RowBytes  ;M
  74.  
  75.     :M putDest: { x y \ x0 y0 -- } size: BndsRect -> y0 -> x0
  76.             x y x0 x + y0 y + put: destRect ;M
  77.  
  78.     :M draw: idxbase +base Put: BaseAddr
  79.             abs: self portBit: actw
  80.             abs: BndsRect abs: destRect
  81.             word0 0 call copyBits ;M
  82.  
  83.     :M offset: ( dx dy -- ) offset: destrect ;M
  84.  
  85.     :M moveto: ( x y -- ) putDest: self draw: self ;M
  86.  
  87. ;CLASS
  88.  
  89. 5 bmap darrow    \ instantiate a global down pointing arrow
  90. hex
  91. $ ff80 $ 7f00 $ 3e00 $ 1c00 $ 0800  put: darrow
  92. decimal
  93. 2 0 0 9 5 init: darrow
  94.  
  95. \ draw text string justified in a given rectangle
  96. : ctextbox { addr len arect just -- }
  97.         addr +base len aRect +base just makeint call textbox ;
  98.  
  99. \ definition of class that handles popup menus
  100.  
  101. \ popupRect provides a way to use pmenu
  102. \    two kinds of disp/print are supported:
  103. \        display a fixed name string or
  104. \        display the last selected item in menu
  105.  
  106. :CLASS popUpMenu <super pMenu
  107.     int            dmode        \ display mode: ITEM (0) or NAME (1)
  108.     var            myAction    \ Menu has an action independent of item handler
  109.     var            myWindow    \ owning window
  110. 33    bytes        name        \ string holds name of rect...limited to 32 characters
  111.     int         txFont      \ retains its type of font
  112.     int         txSize
  113.     int         txFace
  114.     int            txJust        \ justification left(0), center(1), right(-1)
  115.     rect        myBorder    \ rectangle framing menu
  116.  
  117.   :M placeDarrow: getBotX: myBorder
  118.         13 - size: myBorder swap drop 2/ getTopY: myBorder + 2- putDest: darrow ;M
  119.  
  120. \ *** initializing methods ***
  121.   :M font: ( font size face -- ) put: txFace put: txSize put: txFont ;M
  122.   :M justify: put: txJust ;M
  123.   :M actions: put: myAction ;M
  124.   :M putWindow: put: myWindow ;M
  125.   :M setMode: ( displayMode -- ) put: dmode ;M
  126.   :M putRect: ( l t r b -- ) put: myBorder placeDarrow: self
  127.         getTop: myBorder offset: self ;M
  128.  
  129.   :M initFont: pushPort set: [ obj: myWindow ]
  130.         get: txFont tfont get: txSize tsize get: txFace tface popPort ;M
  131.  
  132.   :M getRect: ( -- topx topy botx boty ) get: myBorder ;M
  133.  
  134.   :M name: ( addr len -- ) dup 32 > classerr" 133 addr: name >str255 drop ;M
  135.  
  136.   :M getName: ( -- addr len ) addr: name count ;M
  137.  
  138.   :M print: ( -- ) pushPort actw obj: myWindow -> actw set: actw
  139.         2 1 inset: myBorder getBotX: myBorder dup 10 - putBotX: myBorder
  140.         1 tmode initFont: self
  141.         getName: self addr: myBorder get: txJust ctextBox 
  142.         putBotX: myBorder -2 -1 inset: myBorder  placeDarrow: self draw: darrow
  143.         -> actw popPort ;M
  144.  
  145.   :M draw: ( -- ) pushPort set: [ obj: myWindow ]
  146.         1 1 offset: myBorder draw: myBorder
  147.         -1 -1 offset: myBorder clear: myBorder draw: myBorder print: self popPort ;M
  148.  
  149.   :M ptIn: ( point --) ptIn: myBorder ;M
  150.  
  151.   :M exec: ( -- ) where: theMouse pack ptin: self
  152.         IF popup: self
  153.             mitem 0>        \ don't do anything if no item selected
  154.             IF get: dmode 0=
  155.                 IF    mitem checkOne: self mitem getText: self name: self print: self THEN
  156.                 exec: myAction
  157.             THEN
  158.         THEN ;M
  159.  
  160.   :M firstName: get: dmode 0=
  161.         IF getItem: self  get: super
  162.             name: self print: self
  163.         THEN ;M
  164.  
  165.   :M classinit: ( -- )  classinit: super
  166.         12 put: txSize 1 put: type  nullcfa put: myAction ;M
  167.  
  168. ;CLASS
  169.  
  170. \ EXAMPLE - create a menu in a resource file with ID 128 and 4 items
  171. \ " .rsrc" openresfile
  172. \ 
  173. \ 4 popUpMenu SampleMen        \ instantiate
  174. \ : itemHandler home mitem . ;
  175. \ 4 'cfas itemHandler itemHandler itemHandler itemHandler 128 put: SampleMen
  176. \ fwind putWindow: SampleMen
  177. \ 
  178. \ 240 18 320 34 putRect: SampleMen
  179. \ 0 12 0 font: SampleMen
  180. \ konstant tejustleft justify: SampleMen
  181. \ 
  182. \ getnew: SampleMen        \ read menu from resource file
  183. \ insert: SampleMen        \ insert it into the menubar
  184. \ 
  185. \ : doSample exec: sampleMen ;
  186. \ : drawSample draw: sampleMen ;
  187. \ 4 'cfas null null drawSample doSample actions: fwind
  188. \ 
  189. \ draw: sampleMen
  190.